home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / comunic / twft099b.zip / TWMAP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-07  |  13KB  |  478 lines
  1. Unit TwMap;
  2. {
  3. Copyright (C) 1993 by David Myers.  All rights reserved.  Personal
  4. copying and use of this code permitted.  This source cannot be
  5. sold or distributed for more than the cost of media.
  6. }
  7. interface
  8. uses
  9.   Crt,FlyCom,FParser,TwScr,TwBuffer,TwAnsi,TwLine,TwTrade,TwLaunch;
  10.  
  11. { From TwLaunch: we have access to:
  12. const
  13.   MaxSectors = 1000;
  14. type
  15.   DistType = RECORD
  16.     Sector, Distance : Integer;
  17.   END;
  18.   SectorArray = ARRAY[1 .. MaxSectors] of byte;
  19.   MaxDistType = ARRAY[ 1 .. 25] of DistType;
  20. var
  21.   MySectors : SectorArray;
  22.   MaxDist : integer;
  23.   MaxDistArray : MaxDistType;
  24.  
  25. }
  26.  
  27. Procedure ParseMap;
  28.  
  29.  
  30. implementation
  31.  
  32. type
  33.   AdjList = ARRAY[1 .. MaxSectors, 1 .. 6] of integer;
  34.   AdjListPtr = ^AdjList;
  35.   MyQ = RECORD
  36.     Q: ARRAY[1 .. MaxSectors] of Integer;
  37.     head : integer;
  38.     tail : integer;
  39.   END;
  40.  
  41. Procedure InitList(var A : AdjListPtr);
  42. BEGIN
  43.   new(A);
  44. END;
  45.  
  46. Procedure TerminateList(var A : AdjListPtr);
  47. BEGIN
  48.   dispose(A);
  49. END;
  50.  
  51. {----- queue procedures (see Sedgewick, ALGORITHMS) -----}
  52. Procedure InitQ(var Q : MyQ);
  53. BEGIN
  54.   Q.head := 1;
  55.   Q.tail := 1;
  56. END;
  57.  
  58. Procedure PutQ(var Q : MyQ; i : integer);
  59. BEGIN
  60.   Q.Q[Q.tail] := i;
  61.   Inc(Q.tail);
  62.   If (Q.tail > MaxSectors) then
  63.     Q.tail := 1;
  64. END;
  65.  
  66. Function GetQ(var Q : MyQ) : integer;
  67. var
  68.   t : integer;
  69. BEGIN
  70.   t := Q.Q[Q.head];
  71.   Inc(Q.head);
  72.   if (Q.head > MaxSectors) then
  73.     Q.head := 1;
  74.   GetQ := t;
  75. END;
  76.  
  77. Function QEmpty(var Q : MyQ) : Boolean;
  78. BEGIN
  79.   If (Q.head = Q.tail) then
  80.     QEMpty := TRUE
  81.   ELSE QEMpty := FALSE;
  82. END;
  83. { ----- end queue procedures -----}
  84.  
  85. { breadth first search, used to find distances on TW universe }
  86. { implemented on a FIFO queue, a la Sedgewick                 }
  87.  
  88. Procedure BFSVisit(node : integer; A : AdjListPtr; var V : SectorArray);
  89. const
  90.   UNSEEN = 0;
  91. var
  92.   i,t : integer;
  93.   dist : byte;
  94.   Q : MyQ;
  95.  
  96. BEGIN
  97.   InitQ(Q);
  98.   for i := 1 to 1000 do
  99.     V[i] := UNSEEN;
  100.   PutQ(Q,node);
  101.   V[node] := 255;
  102.   While (NOT QEmpty(Q)) do
  103.     BEGIN
  104.       node := GetQ(Q);
  105.       dist := V[node];
  106.       if (dist > 250) then
  107.         dist := 0;
  108.       for i := 1 to 6 do begin
  109.         t := A^[node][i];
  110.         if (t > 0) then begin
  111.           if (V[t] = UNSEEN) then begin
  112.             PutQ(Q,t);
  113.             V[t] := dist+1;
  114.           end;
  115.         end;
  116.       end;
  117.     END;
  118.  
  119. END;
  120. {
  121.   routine for generating level diagrams as described by Woody Weaver
  122.   in the documentation file MAPPING.TXT
  123. }
  124. Procedure ParseMap;
  125. label
  126.   TheEnd;
  127. type
  128.   BoolArray = ARRAY[1 .. 1000] of Boolean;
  129. var
  130.   A : AdjListPtr;
  131.   V : SectorArray;
  132.   i, j, k, index, ec1, toks, Root, X, Y : integer;
  133.   OldSector, NewSector : integer;
  134.   tokstr,ptok,inputstr,answer,S : string;
  135.   MyFile, MyName : string;
  136.   P : parsetype;
  137.   Loop, Done : Boolean;
  138.   Terminal : BoolArray;
  139.   isSct, SkipCIM,NewWarp : Boolean;
  140.   F : text;
  141.  
  142. BEGIN
  143.    InitList(A);
  144.    Loop := TRUE;
  145.    tokstr := ' '+#9+#8+#10+#13;
  146.    ptok := ' .'+#9+#8+#10+#13;
  147.    for i := 1 to 1000 do begin
  148.      Terminal[i] := TRUE;
  149.      V[i] := 0;
  150.      for j := 1 to 6 do
  151.        A^[i][j] := 0;
  152.    end;
  153.    SaveScreen(X,Y);
  154.    TextColor(LightCyan);
  155.    TextBackGround(Blue);
  156.    WFrameW(5,5,45,12);
  157.    ClrScr;
  158.    TextColor(Yellow);
  159.    Write(' What Root do you want? ');
  160.    TextColor(White);
  161.    ReadLn(Root);
  162.    TextColor(Yellow);
  163.    Write('   Skip CIM report Y/n? ');
  164.    TextColor(WHite);
  165.    ReadLn(Answer);
  166.    If (length(Answer) = 0) or (Answer[1] = 'Y') or (Answer[1] = 'y') then
  167.      SkipCIM := TRUE
  168.    else SkipCIM := FALSE;
  169.    TextColor(Yellow);
  170.    Write(' AST or SCT report A/s? ');
  171.    TextColor(White);
  172.    ReadLn(Answer);
  173.    If (length(Answer) = 0) or (Answer[1] = 'A') or (Answer[1] = 'a') then
  174.      isSCT := FALSE
  175.    else isSCT := TRUE;
  176.    WriteLn;
  177.    Write(' File Name : ');
  178.    BuildString(MyName);
  179.    toks := Parse_Str(ptok,MyName,P);
  180.    if (toks > 0) then
  181.      MyName := P.s[0]
  182.    ELSE MyName := 'LEVDIAG';
  183.    RestoreScreen;
  184.    SelectWindow(1);
  185.    TextColor(White);
  186.    TextBackground(Red);
  187.    ClrScr;
  188.    Write(' -----====== ALT-W Level Diagram Collection; ALT-Q Quits =====----- ');
  189.    SelectWindow(2);
  190.    NormalVideo;
  191.    GotoXY(X,Y);
  192.    Async_Send('C');
  193.    REPEAT
  194.      GetALine(toks,tokstr,inputstr,'?',P,Loop);
  195.    UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  196.    If Loop and NOT SkipCIM then begin
  197.      Delay(1000);
  198.      Async_Send_String('╚╔╩╦╠═');
  199.      REPEAT
  200.        GetALine(toks,tokstr,inputstr,':',P,Loop);
  201.      UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],':'));
  202.      If Loop then begin
  203.        Delay(1000);
  204.        Async_Send('I');
  205.        REPEAT
  206.          GetALine(toks,tokstr,inputstr,':',P,Loop);
  207.          if (Isdigit(P.s[0][1])) then begin
  208.            Val(P.s[0],index,ec1);
  209.            if ec1 = 0 then
  210.              for j := 1 to toks-1 do
  211.                Val(P.s[j],A^[index][j],ec1); { fill .SCT array }
  212.          end;
  213.        UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],':'));
  214.          Delay(1000);
  215.          Async_Send('Q'); { out of CIM }
  216.        REPEAT
  217.          GetALine(toks,tokstr,inputstr,'?',P,Loop);
  218.        UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  219.      end; { if Loop }
  220.      BFSVisit(Root,A,V);
  221.    end; {if Loop and NOT SkipCIM }
  222.    { okay, ready for course plotting }
  223.    { so calculate distances }
  224.    V[Root] := 255;
  225.    Terminal[Root] := FALSE;
  226.    for i := 1 to 1000 do
  227.      if V[i] > 0 then
  228.        Terminal[i] := FALSE;
  229.   j := 0;
  230.   While (j < 1000) do begin
  231.     Inc(j);
  232.     If ((V[j] = 0) and (J <> Root) and Terminal[j]) then begin
  233.       Async_Send('F');
  234.       REPEAT
  235.         GetALine(toks,tokstr,inputstr,'?',P,Loop);
  236.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  237.       if Loop then begin
  238.       Str(Root,S);
  239.       S := S + #13;
  240.       Async_Send_String(S);
  241.       REPEAT
  242.         GetALine(toks,tokstr,inputstr,'?',P,Loop);
  243.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'sector?'));
  244.       if Loop then begin
  245.       Str(j,S);
  246.       S := S + #13;
  247.       Async_Send_String(S);
  248.       REPEAT
  249.         GetALine(toks,tokstr,inputstr,':',P,Loop);
  250.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'is:'));
  251.       if Loop then begin
  252.       NewWarp := False;
  253.       OldSector := 0;
  254.       REPEAT
  255.         GetALine(toks,tokstr,inputstr,' ?',P,Loop);
  256.         { LastAttr is a global variable created by the ansi driver
  257.           to save the previous screen attributes }
  258.         If MatchToken(P.s[0],'>') then
  259.           NewWarp := TRUE
  260.         else begin
  261.         If isdigit(P.s[0][1]) then begin
  262.           if NewWarp then begin
  263.             NewWarp := False;
  264.             Val(P.s[0],NewSector,ec1);
  265.             if (ec1 = 0) then begin
  266.               if (OldSector > 0) then begin
  267.                 Terminal[OldSector] := FALSE;
  268.                 k := 1;
  269.                 Done := FALSE;
  270.                 While ((k < 7) and NOT Done) do begin
  271.                   if (A^[OldSector][k] = 0) then
  272.                     Done := TRUE
  273.                   else if (A^[OldSector][k] = NewSector) then begin
  274.                     Done := TRUE;
  275.                     k := 7;
  276.                   end
  277.                   else begin
  278.                     Inc(k);
  279.                     if (k > 6) then
  280.                       Done := TRUE;
  281.                   end;
  282.                 end;
  283.                 If (k < 7) then
  284.                   A^[OldSector][k] := NewSector;
  285.               end; { OldSector > 0}
  286.               OldSector := NewSector;
  287.             end;
  288.           end
  289.           else begin
  290.             Val(P.s[0],NewSector,ec1);
  291.             If (ec1 = 0) then
  292.               OldSector := NewSector
  293.             else OldSector := 0;
  294.           end;
  295.         end; { if Isdigit.. }
  296.         If MatchToken(P.s[toks-1],'Avoids?') then begin
  297.           { this "if" should work but it doesn't..}
  298.           Delay(2500);
  299.           Async_Send('N');
  300.           Async_Send(#13);
  301.         end;
  302.         end; { else MatchToken to '>'  }
  303.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  304.       if Loop then begin { #4 }
  305.        { do nothing so far .. }
  306.       end; { loopit #4 }
  307.       end; { loopit #3 }
  308.       end; { loopit #2 }
  309.       end; { loopit #1 }
  310.     end;
  311.   end;
  312.   { end of root ---> sector paths }
  313.   if NOT Loop then
  314.     goto TheEnd;
  315.   j := 0;
  316.   While (j < 1000) do begin
  317.     Inc(j);
  318.     If Terminal[j] and (J <> Root) then begin
  319.       Async_Send('F');
  320.       REPEAT
  321.         GetALine(toks,tokstr,inputstr,'?',P,Loop);
  322.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  323.       if Loop then begin
  324.       Str(J,S);
  325.       S := S + #13;
  326.       Async_Send_String(S);
  327.       REPEAT
  328.         GetALine(toks,tokstr,inputstr,'?',P,Loop);
  329.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'sector?'));
  330.       if Loop then begin
  331.       Str(Root,S);
  332.       S := S + #13;
  333.       Async_Send_String(S);
  334.       REPEAT
  335.         GetALine(toks,tokstr,inputstr,':',P,Loop);
  336.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'is:'));
  337.       if Loop then begin
  338.       NewWarp := False;
  339.       OldSector := 0;
  340.       REPEAT
  341.         GetALine(toks,tokstr,inputstr,' ?',P,Loop);
  342.         { LastAttr is a global variable created by the ansi driver
  343.           to save the previous screen attributes }
  344.         If MatchToken(P.s[0],'>') then
  345.           NewWarp := TRUE
  346.         else begin
  347.         If isdigit(P.s[0][1]) then begin
  348.           if NewWarp then begin
  349.             NewWarp := False;
  350.             Val(P.s[0],NewSector,ec1);
  351.               if (ec1 = 0) then begin
  352.               if (OldSector > 0) then begin
  353.                 k := 1;
  354.                 Done := FALSE;
  355.                 While ((k < 7) and NOT Done) do begin
  356.                   if (A^[OldSector][k] = 0) then
  357.                     Done := TRUE
  358.                   else if (A^[OldSector][k] = NewSector) then begin
  359.                     Done := TRUE;
  360.                     k := 7;
  361.                   end
  362.                   else begin
  363.                     Inc(k);
  364.                     if (k > 6) then
  365.                       Done := TRUE;
  366.                   end;
  367.                 end;
  368.                 If (k < 7) then
  369.                   A^[OldSector][k] := NewSector;
  370.               end; { OldSector > 0}
  371.               OldSector := NewSector;
  372.             end;
  373.           end
  374.           else begin
  375.             Val(P.s[0],NewSector,ec1);
  376.             If (ec1 = 0) then
  377.               OldSector := NewSector
  378.             else OldSector := 0;
  379.           end;
  380.         end; { if Isdigit.. }
  381.         If MatchToken(P.s[toks-1],'Avoids?') then begin
  382.           { this "if" should work but it doesn't..}
  383.           Delay(2500);
  384.           Async_Send('N');
  385.           Async_Send(#13);
  386.         end;
  387.         end; { else MatchToken to '>'  }
  388.       UNTIL ((NOT Loop) or MatchToken(P.s[toks-1],'?'));
  389.       if Loop then begin { #4 }
  390.        { do nothing so far .. }
  391.       end; { loopit #4 }
  392.       end; { loopit #3 }
  393.       end; { loopit #2 }
  394.       end; { loopit #1 }
  395.     end;
  396.   end;
  397.   Async_Send('Q');
  398. TheEnd:
  399.   BFSVisit(Root,A,V);
  400.   {
  401.     set this up to write either a .SCT report or a more compact
  402.     .AST report
  403.   }
  404.   if isSct then begin
  405.     MyFile := MyName + '.SCT';
  406.     Assign(F,MyFile);
  407.     Rewrite(F);
  408.     WriteLn(F);
  409.     WriteLn(F);
  410.     for i := 1 to 1000 do begin
  411.       Write(F,i:4);
  412.       if (A^[i][1] = 0) then
  413.         WriteLn(F,'    0')
  414.       else begin
  415.         j := 1;
  416.         While (j < 7) and (A^[i][j] <> 0) do begin
  417.           Write(F,A^[i][j]:5);
  418.           Inc(j);
  419.         end;
  420.         WriteLn(F);
  421.       end;
  422.       WriteLn(F);
  423.     end;
  424.     WriteLn(F);
  425.     WriteLn(F);
  426.     WriteLn(F,':');
  427.     Close(F);
  428.   { end of .SCT support }
  429.   end
  430.   else begin
  431.     MyFile := MyName + '.AST';
  432.     Assign(F,MyFile);
  433.     Rewrite(F);
  434.     WriteLn(F,':');
  435.     for i := 1 to 1000 do begin
  436.       Write(F,i:4);
  437.       if (A^[i][1] = 0) then
  438.         WriteLn(F,'    0')
  439.       else begin
  440.         j := 1;
  441.         While (j < 7) and (A^[i][j] <> 0) do begin
  442.           Write(F,A^[i][j]:5);
  443.           Inc(j);
  444.         end;
  445.         WriteLn(F);
  446.       end;
  447.     end;
  448.     WriteLn(F);
  449.     WriteLn(F,': ENDINTERROG');
  450.     Close(F);
  451.   { end of .AST support }
  452.   end;
  453.   { writing a .DIS file }
  454.   MyFile := MyName + '.DIS';
  455.   Assign(F,MyFile);
  456.   ReWrite(F);
  457.   for i := 1 to 1000 do begin
  458.     if V[i] > 200 then
  459.       WriteLn(F,i:4,'   -1')
  460.     else
  461.       WriteLn(F,i:4,V[i]:5);
  462.   end;
  463.   Close(F);
  464.   { writing a .EXT file }
  465.   MyFile := MyName + '.EXT';
  466.   Assign(F,MyFile);
  467.   ReWrite(F);
  468.   for i := 1 to 1000 do begin
  469.     if Terminal[i] then
  470.       WriteLn(F,i:4)
  471.   end;
  472.   Close(F);
  473. { TheEnd: }
  474.   TopLine;
  475.   TerminateList(A);
  476. END;
  477.  
  478. END.